home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / wb1a1.lha / wb / handle.scm < prev    next >
Encoding:
Text File  |  1993-06-29  |  13.4 KB  |  391 lines
  1. ; Wb-tree File Based Associative String Data Base System.
  2. ; Copyright (c) 1991, 1992, 1993 Holland Mark Martin
  3. ;
  4. ;Permission to use, copy, modify, and distribute this software and its
  5. ;documentation for educational, research, and non-profit purposes and
  6. ;without fee is hereby granted, provided that the above copyright
  7. ;notice appear in all copies and that both that copyright notice and
  8. ;this permission notice appear in supporting documentation, and that
  9. ;the name of Holland Mark Martin not be used in advertising or
  10. ;publicity pertaining to distribution of the software without specific,
  11. ;written prior consent in each case.  Permission to incorporate this
  12. ;software into commercial products can be obtained from Jonathan
  13. ;Finger, Holland Mark Martin, 174 Middlesex Turnpike, Burlington, MA,
  14. ;01803-4467, USA.  Holland Mark Martin makes no representations about
  15. ;the suitability or correctness of this software for any purpose.  It
  16. ;is provided "as is" without express or implied warranty.  Holland Mark
  17. ;Martin is under no obligation to provide any services, by way of
  18. ;maintenance, update, or otherwise.
  19.  
  20. ;; routines in this file return success codes
  21.  
  22. (require (in-vicinity (program-vicinity) "sys"))
  23.  
  24. ;;;; BT Stuff
  25.  
  26. (define (bt-open seg blk-num han wcb)
  27.   (if (and (>= seg 0) (< seg NUM-SEGS) (SEG-STR seg)) ;allocated
  28.       (let ((ent (get-ent seg blk-num ACCREAD)))
  29.     (cond ((not ent) UNKERR)
  30.           ((not (root? (ENT-BLK ent)))
  31.            (release-ent! ent ACCREAD)
  32.            (fprintf diagout ">>>>ERROR<<<<BT-OPEN: not a root %d:%d\\n"
  33.             seg blk-num)
  34. ;;;           (check-access!)
  35.            ARGERR)
  36.           (else
  37.            (HAN-SET-SEG! han seg)
  38.            (HAN-SET-NUM! han blk-num)
  39.            (HAN-SET-TYP! han (BLK-TYP (ENT-BLK ent))) ;TBD improve. (eh?)
  40.            (HAN-SET-LAST! han blk-num)
  41.            (if (BLK-TYP? (ENT-BLK ent) DIR-TYP)
  42.            (set! wcb (logior wcb (+ WCB-SAP WCB-SAR))))
  43.            (HAN-SET-WCB! han wcb)           
  44.            (release-ent! ent ACCREAD)
  45. ;;;           (check-access!)
  46.            (HAN-TYP han))))
  47.       ARGERR))
  48.  
  49. (define (bt-create seg typ han wcb)
  50.   (define ent (create-new-blk-ent seg))
  51.   (cond ((not ent) NOROOM)
  52.     (else (let* ((blk-num (ENT-ID ent)))
  53.          (init-leaf-blk! (ENT-BLK ent) blk-num typ)
  54.          (ENT-SET-DTY! ent #t)
  55.          (ENT-SET-PUS! ent 0)
  56.          (ent-write ent)
  57.          (HAN-SET-SEG! han seg)
  58.          (HAN-SET-NUM! han blk-num)
  59.          (HAN-SET-TYP! han typ)
  60.          (HAN-SET-LAST! han blk-num)
  61.          (if (eqv? typ DIR-TYP)
  62.          (set! wcb (logior wcb (+ WCB-SAP WCB-SAR))))
  63.          (HAN-SET-WCB! han wcb)
  64.          (release-ent! ent ACCWRITE)
  65. ;;;         (check-access!)
  66.          SUCCESS))))
  67.  
  68. (define (bt-close han)
  69.   (HAN-SET-SEG! han 0)
  70.   (HAN-SET-NUM! han 0)
  71.   (HAN-SET-TYP! han 0)
  72.   (HAN-SET-LAST! han 0)
  73.   SUCCESS)
  74.  
  75. (define clever-cache-enable #t)
  76.  
  77. ;; NOTE: Please note that most of the data-manipulating commands here
  78. ;; can return NOTPRES, with the followng meanings:
  79. ;; GET:    no such key
  80. ;; NEXT:   no NEXT key (ie, key given was LAST key)
  81. ;; PREV:   no PREV key (ie, key given was FIRST key)
  82. ;; REM:    KEY was not found
  83. ;; REM-RANGE: ??
  84. ;; PUT:    NOT USED (could be symmetric w/WRITE)
  85. ;; WRITE:  key WAS found, so no write done
  86.  
  87. (define (bt-get han key-str k-len ans-str)
  88.   (define pkt (make-vector PKT-SIZE))
  89.   (define ent #f)
  90. ;;;  (fprintf diagout "bt-get %d:%ld %.*s\\n" (HAN-SEG han) (HAN-ID han)
  91. ;;;       (max 0 k-len) key-str)
  92.   (set! ent (chain-find-ent han ACCREAD key-str k-len pkt))
  93.   (cond ((not ent) (set! get-fct (+ 1 get-fct))
  94.             UNKERR)
  95.     ((not (eq? (MATCH-TYPE pkt) MATCH))
  96.      (set! get-ct (+ 1 get-ct))
  97.      (release-ent! ent ACCREAD)
  98.      NOTPRES)
  99.     (else
  100.      (let ((alen (get-this-val (ENT-BLK ent) (MATCH-POS pkt) ans-str)))
  101.        (set! get-ct (+ 1 get-ct))
  102.        (release-ent! ent ACCREAD)
  103.        alen))))
  104.  
  105. (define (bt-next han key-str k-len ans-str)
  106.   (define pkt (make-vector PKT-SIZE))
  107.   (define ent #f)
  108. ;  (fprintf diagout "bt-next %d:%ld %.*s\\n" (HAN-SEG han) (HAN-ID han)
  109. ;       (max 0 k-len) key-str)
  110.   (set! ent (chain-find-ent han ACCREAD key-str k-len pkt))
  111.   (cond ((not ent)
  112.      (set! next-fct (+ 1 next-fct))
  113.      UNKERR)
  114.     (else
  115.      (set! next-ct (+ 1 next-ct))
  116.      (let ((res (chain-next ent key-str k-len ans-str pkt)))
  117.        (if clever-cache-enable (HAN-SET-LAST! han (BLK-TO-CACHE pkt)))
  118.        res))))
  119.  
  120. (define (bt-prev han key-str k-len ans-str)
  121.   (define pkt (make-vector PKT-SIZE))
  122.   (define ent #f)
  123. ;  (fprintf diagout "bt-prev %d:%ld %.*s\\n" (HAN-SEG han) (HAN-ID han)
  124. ;       (max 0 k-len) key-str)
  125.   (set! ent (chain-find-prev-ent han ACCREAD key-str k-len pkt))
  126.   (and ent (set! ent (prev-k-ent ent key-str k-len LEAF pkt)))
  127.   (cond ((not ent)
  128.      (set! prev-fct (+ 1 prev-fct))
  129.      UNKERR)
  130.     (else
  131.      (set! prev-ct (+ 1 prev-ct))
  132.      (if (zero? (MATCH-POS pkt))
  133.          (begin (release-ent! ent ACCREAD) NOTPRES)
  134.          (let ((k-len2 (recon-this-key (ENT-BLK ent)
  135.                        (MATCH-POS pkt) ans-str 0 256)))
  136.            (HAN-SET-LAST! han (ENT-ID ent))
  137.            (release-ent! ent ACCREAD)
  138.            k-len2)))))
  139.  
  140. ;;; rem removes key and value.  returns SUCCESS if found, #f if not.
  141.  
  142. (define (bt-rem han key-str k-len ans-str)
  143.   (define pkt (make-vector PKT-SIZE))
  144.   (define ent #f)
  145. ;  (fprintf diagout "bt-rem %d:%ld %.*s\\n" (HAN-SEG han) (HAN-ID han)
  146. ;       (max 0 k-len) key-str)
  147.   (cond ((< k-len 0)
  148.      (fprintf diagout ">>>>ERROR<<<< bt-rem: bad length string %d\\n" k-len)
  149.      ARGERR)
  150.     (else
  151.      (set! ent (chain-find-ent han ACCWRITE key-str k-len pkt))
  152.      (cond (ent
  153.         (set! rem-ct (+ 1 rem-ct))
  154.         (let ((ans (chain-rem ent key-str k-len ans-str pkt (HAN-WCB han))))
  155.           (release-ent! ent ACCWRITE)
  156.           ans))
  157.            (else
  158.         (set! rem-fct (+ 1 rem-fct))
  159.         UNKERR)))))
  160.  
  161. ;;; rem-range removes [key1 .. key2) and their values.
  162. ;;; If key2<=key1 no deletion will occur (even if key1 is found).
  163. ;;; To make possible bounded-time operation rem-range will
  164. ;;; clean out at most BLK-LIMIT blocks at a time; if you dont care,
  165. ;;; give it -1 for BLK-LIMIT.  Rem-range returns SUCCESS if the operation
  166. ;;; is complete, NOTPRES or RETRYERR if not (meaning you need to call it again).
  167. ;;; ***WARNING*** In the latter cases, it MODIFIES the KEY1 string
  168. ;;; so that the string args are correctly set up for the next call
  169. ;;; (The new length for KEY1 is in (KEY-LEN respkt)).
  170. ;;; Therefore, KEY-STR MUST BE A MAXIMUM-LENGTH STRING [!!]
  171.  
  172. (define (bt-rem-range han key-str k-len key2-str k2-len)
  173.   (define respkt (make-vector PKT-SIZE))
  174.   (bt-scan han REM-SCAN key-str k-len key2-str k2-len #f #f respkt -1))
  175.  
  176. ;;; put adds an key value pair to the database whose root is blk
  177.  
  178. (define (bt-put han key-str k-len val-str v-len)
  179.   (define ent #f)
  180.   (define pkt (make-vector PKT-SIZE))
  181. ;  (fprintf diagout "bt-put %d:%ld %.*s %.*s\\n"
  182. ;       (HAN-SEG han) (HAN-ID han) (max 0 k-len) key-str v-len val-str)
  183.   (cond ((or (> v-len 255) (> k-len 255) (< k-len 0))
  184.      ARGERR)
  185.     (else
  186.      (set! ent (chain-find-ent han ACCWRITE key-str k-len pkt))
  187.      (if ent
  188.          (let ((res (chain-put ent key-str k-len val-str v-len pkt #f (HAN-WCB han))))
  189.            (cond (res
  190.               (if clever-cache-enable
  191.               (HAN-SET-LAST! han (BLK-TO-CACHE pkt)))
  192.               (set! put-ct (+ 1 put-ct))
  193.               SUCCESS)
  194.              (else
  195.               (set! put-fct (+ 1 put-fct))
  196.               UNKERR)))
  197.          UNKERR))))
  198.  
  199. ;; note: returns NOTPRES if the key is PRESENT, else writes it and returs SUCCESS.
  200.  
  201. (define (bt-write han key-str k-len val-str v-len)
  202.   (define ent #f)
  203.   (define pkt (make-vector PKT-SIZE))
  204.   (cond
  205.    ((or (> v-len 255) (> k-len 255) (< k-len 0))
  206.     ARGERR)
  207.    (else
  208.     (set! ent (chain-find-ent han ACCWRITE key-str k-len pkt))
  209.     (if ent
  210.     (if (eq? (MATCH-TYPE pkt) MATCH)
  211.         (begin (release-ent! ent ACCWRITE) NOTPRES) ;DTY has not been set.
  212.         (let ((res (chain-put ent key-str k-len val-str v-len pkt #f (HAN-WCB han))))
  213.           (cond (res
  214.              (if clever-cache-enable
  215.              (HAN-SET-LAST! han (BLK-TO-CACHE pkt)))
  216.              (set! put-ct (+ 1 put-ct))
  217.              SUCCESS)
  218.             (else
  219.              (set! put-fct (+ 1 put-fct))
  220.              UNKERR))))
  221.     UNKERR))))
  222.  
  223. ;;;; Segment procedures
  224.  
  225. (define db-version-str "WB-trees   1a1")
  226. (define db-authors-str "A. Jaffer, J. Finger, R. Zito-Wolf")
  227.  
  228. (define (seg-free? seg)
  229.   (if (not lck-tab) (init-wb 75 150 2048))
  230.   (cond ((or (negative? seg) (>= seg NUM-SEGS))
  231.      (fprintf diagout ">>>>ERROR<<<< bad segment number %d\\n" seg)
  232.      #f)
  233.     ((and (not (SEG-PORT seg))
  234.           (not (SEG-STR seg))
  235.           (not (SEG-USED seg)))
  236.      #t)
  237.     (else #f)))
  238.  
  239. ;TBD - need to lck seg here.
  240. ;; Segment will be read-only if MODE is #f.
  241.  
  242. (define (open-seg seg name mode)
  243.   (define bsiz #f)
  244.   (define (errout reason-str)
  245.     (fprintf diagout ">>>>ERROR<<<< not a database %s %s\\n" name reason-str)
  246.     (blk-file-close (SEG-PORT seg))
  247.     (SEG-SET-PORT! seg #f)
  248.     (SEG-SET-STR! seg #f)
  249.     (SEG-SET-USED! seg #f)
  250.     TYPERR)
  251.   (if (zero? mode) (set! mode #f))
  252.   (cond
  253.    ((not (seg-free? seg))
  254.     (fprintf diagout ">>>>ERROR<<<< open-seg:segment in use %d\\n" seg)
  255.     ARGERR)
  256.    ((begin
  257.       (set! bsiz (min-file-blk-size name))
  258.       (set! bsiz (max (* 3 128) bsiz))
  259.       ;;temporarily set bsiz so that we can get it from superblk
  260.       (> bsiz blk-size))
  261.     (fprintf diagout ">>>>ERROR<<<< unsupported bsiz %d > %d\\n" bsiz blk-size)
  262.     ARGERR)
  263.    (else
  264.     (let loop ((file (if mode (blk-file-open-modify name bsiz)
  265.              (blk-file-open-read-only name bsiz))))
  266.       (cond
  267.        ((if mode (output-port? file) (input-port? file))
  268.     (SEG-SET-PORT! seg file)
  269.     (SEG-SET-STR! seg name)
  270.     (SEG-SET-USED! seg 2)
  271.     (SEG-SET-BSIZ! seg bsiz)
  272.     (SEG-SET-FLC-LEN! seg (if mode -1 -2)) ;-1 means to read in "FLC" image.
  273.                     ;-2 means read only.
  274.     (let ((han (SEG-RT-HAN seg))
  275.           (tmp-str (make-string 5))) ;this should be longer
  276.       (cond
  277.        ((err? (bt-open seg 0 han (+ WCB-SAP WCB-SAR))) ; superblock
  278.         (errout "bt-open 0"))
  279.        ((not (eq? 2 (bt-get han "BSIZ" 4 tmp-str)))
  280.         (errout "BSIZ"))
  281.        ((not (= bsiz (str2short tmp-str 0)))
  282.         (blk-file-close file)
  283.         (set! bsiz (str2short tmp-str 0))
  284.         (cond
  285.          ((> bsiz blk-size) (errout "BSIZ too big."))
  286.          (else (loop (if mode (blk-file-open-modify name bsiz)
  287.                  (blk-file-open-read-only name bsiz))))))
  288.        ((not (eq? 4 (bt-get han "USED" 4 tmp-str)))
  289.         (errout "USED"))
  290.        (else
  291.         (SEG-SET-USED! seg (str2long tmp-str 0))
  292.         (cond ((not (eq? 5 (bt-get han "FLD" 3 tmp-str)))
  293.            (errout "FLD"))
  294.           ((err? (bt-open seg (str2long tmp-str 1) (SEG-FL-HAN seg) WCB-SAR))
  295.            (errout "FLC"))
  296.           (else
  297.            (if (not  (eqv? (HAN-TYP (SEG-FL-HAN seg)) FRL-TYP))
  298.                 (fprintf diagout "Older type freelist - still supported.\\n"))
  299.            (HAN-SET-WCB! (SEG-FL-HAN seg) WCB-SAR)
  300.            seg))))))
  301.        (else
  302.     (if (if mode (input-port? file) (output-port? file)) (blk-file-close file))
  303.     (fprintf diagout ">>>>ERROR<<<< could not open file %s\\n" name)
  304.     IOERR))))))
  305.  
  306. (define (close-seg seg hammer)
  307.   (cond ((or (not (SEG-STR seg))
  308.          (not (SEG-USED seg)))
  309.      (fprintf diagout ">>>>ERROR<<<< close-seg: segment %d already closed\\n" seg)
  310.      ARGERR)
  311.     (else
  312.      (flush-flc! seg 5)        ;leave only enough blocks to fit in flc in superblock.
  313.      (if (>= (SEG-FLC-LEN seg) 0)
  314.          (let* ((tmp-str (make-string 20)))
  315.            (do ((i (+ -1 (SEG-FLC-LEN seg)) (+ -1 i)))
  316.            ((negative? i))
  317.          (long2str! tmp-str (* 4 i) (vector-ref (SEG-FLC seg) i)))
  318.            (bt-put (SEG-RT-HAN seg) "FLC" 3 tmp-str (* 4 (SEG-FLC-LEN seg)))
  319.            (SEG-SET-FLC-LEN! seg -1)))
  320.      (let ((ans (do-seg-buffers seg flush-buffer)))
  321.        (cond ((or (success? ans) hammer)
  322.           (if (not (success? ans)) (set! ans NOTPRES))
  323.           (do-seg-buffers seg purge-buffer)
  324.           (bt-close (SEG-RT-HAN seg))
  325.           (bt-close (SEG-FL-HAN seg))
  326.           (blk-file-close (SEG-PORT seg))
  327.           (SEG-SET-PORT! seg #f)
  328.           (SEG-SET-STR! seg #f)
  329.           (SEG-SET-USED! seg #f)))
  330.        ans))))
  331.  
  332. (define (make-seg seg name bsiz)
  333.   (cond
  334.    ((or (not (seg-free? seg)) (not (try-lck (SEG-LCK seg))))
  335.     (fprintf diagout ">>>>ERROR<<<< make-seg:segment in use %d\\n" seg)
  336.     ARGERR)
  337.    ((> bsiz blk-size)
  338.     (fprintf diagout ">>>>ERROR<<<< unsupported bsiz %d > %d\\n" bsiz blk-size)
  339.     (unlck! (SEG-LCK seg))
  340.     ARGERR)
  341.    (else
  342.     (let ((file (blk-file-create name bsiz)))
  343.       (cond
  344.        ((output-port? file)
  345.     (SEG-SET-PORT! seg file)
  346.     (SEG-SET-BSIZ! seg bsiz)
  347.     (SEG-SET-USED! seg 3)
  348.     (SEG-SET-STR! seg name)
  349.     (init-leaf-blk! empty-blk 0 DIR-TYP)
  350.     (BLK-SET-TIME! empty-blk (get-universal-time))
  351.     (blk-write file empty-blk bsiz 0)
  352.     (init-leaf-blk! empty-blk 1 DIR-TYP)
  353.     (BLK-SET-TIME! empty-blk (get-universal-time))
  354.     (blk-write file empty-blk bsiz 1)
  355.     (init-leaf-blk! empty-blk 2 FRL-TYP)
  356.     (BLK-SET-TIME! empty-blk (get-universal-time))
  357.     (blk-write file empty-blk bsiz 2)
  358.     (blk-file-close file)
  359.     (set! file (blk-file-open-modify name bsiz))
  360.     (cond ((output-port? file)
  361.            (SEG-SET-PORT! seg file)
  362.            (unlck! (SEG-LCK seg))
  363.            (let ((han (SEG-RT-HAN seg))
  364.              (tmp-str (make-string 5)))
  365.          (bt-open seg 0 han (+ WCB-SAP WCB-SAR))
  366.          (bt-put han "" 0
  367.              db-version-str (string-length db-version-str))
  368.          (long2str! tmp-str 0 (SEG-USED seg))
  369.          (bt-put han "USED" 4 tmp-str 4)
  370.          (short2str! tmp-str 0 (SEG-BSIZ seg))
  371.          (bt-put han "BSIZ" 4 tmp-str 2)
  372.          (string-set! tmp-str 0 (integer->char 4))
  373.          (long2str! tmp-str 1 1)
  374.          (bt-put han "ROOT" 4 tmp-str 5)
  375.          (long2str! tmp-str 1 2)
  376.          (bt-put han "FLD" 3 tmp-str 5)
  377.          (bt-put han "FLC" 3 "" 0)
  378.          (if (> bsiz 128)
  379.              (bt-put han "authors" 7
  380.                  db-authors-str (string-length db-authors-str)))
  381.          (close-seg seg #f)    ;don't close the segment if it is memory resident.
  382.          ))
  383.           (else
  384.            (fprintf diagout ">>>>ERROR<<<< couldn't open fresh file %s\\n"
  385.             name)
  386.            (unlck! (SEG-LCK seg))
  387.            IOERR)))
  388.        (else (fprintf diagout ">>>>ERROR<<<< couldn't create new file %s\\n" name)
  389.          (unlck! (SEG-LCK seg))
  390.          IOERR))))))
  391.